!
! coloring - the engine
!
!
! Copyright © 2010-1 F.Hroch (hroch@physics.muni.cz)
!
! This file is part of Munipack.
!
! Munipack is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
! 
! Munipack is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
! 
! You should have received a copy of the GNU General Public License
! along with Munipack.  If not, see <http://www.gnu.org/licenses/>.
!

module coloring_book

  implicit none


contains
 
  subroutine coloring(cspace,fnames,cname)

    implicit none

    ! the container for headers
    type MetaFits
       integer :: bitpix
       integer, dimension(2) :: naxes
       character(len=80),dimension(:),allocatable :: head
    end type MetaFits

    character(len=*),dimension(:),intent(in) :: fnames
    character(len=*),intent(in) :: cname,cspace

    ! the parameter fnames contains list of filenames in order BVR
    
    integer, parameter :: naxis = 2
    real, parameter :: minvalue = -huge(1.0)
    integer :: bitpix = 8

    integer :: nbands, width, height, nhead
    integer :: i,n,istat, mstat,bpix, pcount,gcount
    integer, dimension(naxis) :: naxes
    integer, dimension(naxis+1) :: naxes3d
    logical :: simple,extend,anyf
    character(len=80) :: buf
    real,dimension(:,:,:),allocatable :: cube
    real,dimension(:,:), allocatable :: ccd
    type(MetaFits), dimension(:), allocatable :: mfits

    nbands = size(fnames)
    
    width = 0
    height = 0

    allocate(mfits(nbands))

    ! load images
    do i = 1,nbands

       istat = 0
       call ftnopn(25,fnames(i),0,istat)
       if( istat /= 0 ) goto 666
       call ftghpr(25,naxis,simple,bpix,n,naxes,pcount,gcount,extend,istat)
       
       if( n /= naxis ) then
          write(*,*) 'Only two dimensional images are supported.'
          stop 31
       end if

       mfits(i)%bitpix = bpix
       mfits(i)%naxes = naxes
              
       if( abs(bpix) > abs(bitpix) ) bitpix = bpix

       call ftghps(25,nhead,n,istat)
       allocate(mfits(i)%head(nhead),stat=mstat)
       if( mstat /= 0 ) then
          write(*,*) 'Not enought memory for your head.'
          stop 31
       end if
       do n = 1, nhead
          call ftgrec(25,n,mfits(i)%head(n),istat)
       enddo       

       if( i == 1 ) then
          width = naxes(1)
          height = naxes(2)
          allocate(cube(width,height,nbands),stat=mstat)
          !if( mstat /= 0 ) stop 'Not enought memory.'
          if( mstat == 0 ) &
               allocate(ccd(width,height),stat=mstat)
          if( mstat /= 0 ) then
             write(*,*) 'Not enought memory..'
             stop 66
          end if
       else if( .not.(naxes(1) == width .and. naxes(2) == height) ) then
          write(*,*) 'Dimensions of images does not corresponds mutually.'
          stop 31
       end if

       call ftg2de(25,1,minvalue,width,width,height,ccd,anyf,istat)
       cube(:,:,i) = ccd

       call ftclos(25,istat)

       if( istat /= 0 ) goto 666

    end do

    deallocate(ccd)


    ! write out FITS color 
    call ftinit(26,cname,1,istat)

    naxes3d = (/ width, height, nbands /) 
    call ftiimg(26,bitpix,3,naxes3d,istat) 

    call ftukys(26,'CSPACE',cspace,'the color space of stored data',istat)

    call ftpcom(26,'Headers of originals:',istat)
    do i = 1,nbands
       call ftpcom(26,'BEGIN '//trim(fnames(i)),istat)
       do n = 1, size(mfits(i)%head)
          call ftpcom(26,mfits(i)%head(n),istat)
       enddo
       call ftpcom(26,'END '//trim(fnames(i)),istat)
    end do

    call ftukys(26,'CREATOR','Munipack','Created by coloring utility of Munipack',istat)

    call ftp3de(26,1,width,height,width,height,nbands,cube,istat)

    if( istat == 412 ) istat = 0 ! numerical overflow during implicit datatype conversion

    call ftclos(26,istat)


666 continue

    do i = 1,nbands
       if( allocated(mfits(i)%head) )deallocate(mfits(i)%head)
    end do
    if( allocated(mfits) ) deallocate(mfits)
    if( allocated(cube) ) deallocate(cube)
    if( allocated(ccd) ) deallocate(ccd)

    if( istat /= 0 ) then
       do
          call ftgmsg(buf)
          if( buf == ' ' ) stop 66
          write(*,*) trim(buf)
       enddo
    end if

  end subroutine coloring

end module coloring_book

